home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / represent.lisp < prev    next >
Encoding:
Text File  |  1992-02-24  |  24.2 KB  |  723 lines
  1. ;;; -*- Package: C; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: represent.lisp,v 1.32 92/02/24 05:50:28 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;;    This file contains the implementation independent code for the
  15. ;;; representation selection phase in the compiler.  Representation selection
  16. ;;; decides whether to use non-descriptor representations for objects and emits
  17. ;;; the appropriate representation-specific move and coerce vops.
  18. ;;;
  19. ;;; Written by Rob MacLachlan
  20. ;;;
  21. (in-package 'c)
  22.  
  23.  
  24. ;;;; Error routines:
  25. ;;;
  26. ;;;    Problems in the VM definition often show up here, so we try to be as
  27. ;;; implementor-friendly as possible.
  28. ;;;
  29.  
  30. ;;; GET-OPERAND-INFO  --  Interface
  31. ;;;
  32. ;;;    Given a TN ref for a VOP argument or result, return these values:
  33. ;;; 1] True if the operand is an argument, false otherwise.
  34. ;;; 2] The ordinal position of the operand.
  35. ;;; 3] True if the operand is a more operand, false otherwise.
  36. ;;; 4] The costs for this operand.
  37. ;;; 5] The load-scs vector for this operand (NIL if more-p.)
  38. ;;; 6] True if the costs or SCs in the VOP-INFO are inconsistent with the
  39. ;;;    currently record ones.
  40. ;;;
  41. (defun get-operand-info (ref)
  42.   (declare (type tn-ref ref))
  43.   (let* ((arg-p (not (tn-ref-write-p ref)))
  44.      (vop (tn-ref-vop ref))
  45.      (info (vop-info vop)))
  46.     (flet ((frob (refs costs load more-cost)
  47.          (do ((refs refs (tn-ref-across refs))
  48.           (costs costs (cdr costs))
  49.           (load load (cdr load))
  50.           (n 0 (1+ n)))
  51.          ((null costs)
  52.           (assert more-cost)
  53.           (values arg-p
  54.               (+ n
  55.                  (or (position-in #'tn-ref-across ref refs)
  56.                  (error "Couldn't find REF?"))
  57.                  1)
  58.               t
  59.               more-cost
  60.               nil
  61.               nil))
  62.            (when (eq refs ref)
  63.          (let ((parse (vop-parse-or-lose (vop-info-name info)
  64.                          *backend*)))
  65.            (multiple-value-bind
  66.                (ccosts cscs)
  67.                (compute-loading-costs
  68.             (elt (if arg-p
  69.                  (vop-parse-args parse)
  70.                  (vop-parse-results parse))
  71.                  n)
  72.             arg-p)
  73.              
  74.              (return
  75.               (values arg-p
  76.                   (1+ n)
  77.                   nil
  78.                   (car costs)
  79.                   (car load)
  80.                   (not (and (equalp ccosts (car costs))
  81.                     (equalp cscs (car load))))))))))))
  82.       (if arg-p
  83.       (frob (vop-args vop) (vop-info-arg-costs info)
  84.             (vop-info-arg-load-scs info)
  85.             (vop-info-more-arg-costs info))
  86.       (frob (vop-results vop) (vop-info-result-costs info)
  87.             (vop-info-result-load-scs info)
  88.             (vop-info-more-result-costs info))))))
  89.  
  90.  
  91. ;;; LISTIFY-RESTRICTIONS  --  Interface
  92. ;;;
  93. ;;;    Convert a load-costs vector to the list of SCs allowed by the operand
  94. ;;; restriction.
  95. ;;;
  96. (defun listify-restrictions (restr)
  97.   (declare (type sc-vector restr))
  98.   (collect ((res))
  99.     (dotimes (i sc-number-limit)
  100.       (when (eq (svref restr i) t)
  101.     (res (svref (backend-sc-numbers *backend*) i))))
  102.     (res)))
  103.  
  104.     
  105. ;;; BAD-COSTS-ERROR  --  Internal
  106. ;;;
  107. ;;;    Try to give a helpful error message when Ref has no cost specified for
  108. ;;; some SC allowed by the TN's primitive-type.
  109. ;;;
  110. (defun bad-costs-error (ref)
  111.   (declare (type tn-ref ref))
  112.   (let* ((tn (tn-ref-tn ref))
  113.      (ptype (tn-primitive-type tn)))
  114.     (multiple-value-bind (arg-p pos more-p costs load-scs incon)
  115.              (get-operand-info ref)
  116.       (collect ((losers))
  117.     (dolist (scn (primitive-type-scs ptype))
  118.       (unless (svref costs scn)
  119.         (losers (svref (backend-sc-numbers *backend*) scn))))
  120.  
  121.     (unless (losers)
  122.       (error "Representation selection flamed out for no obvious reason.~@
  123.               Try again after recompiling the VM definition."))
  124.     
  125.     (error "~S is not valid as the ~:R ~:[result~;argument~] to the~@
  126.             ~S VOP, since the TN's primitive type ~S allows SCs:~%  ~S~@
  127.         ~:[which cannot be coerced or loaded into the allowed SCs:~
  128.         ~%  ~S~;~*~]~:[~;~@
  129.         Current cost info inconsistent with that in effect at compile ~
  130.         time.  Recompile.~%Compilation order may be incorrect.~]"
  131.            tn pos arg-p
  132.            (template-name (vop-info (tn-ref-vop ref)))
  133.            (primitive-type-name ptype)
  134.            (mapcar #'sc-name (losers))
  135.            more-p
  136.            (unless more-p
  137.          (mapcar #'sc-name (listify-restrictions load-scs)))
  138.            incon)))))
  139.  
  140.  
  141. ;;; BAD-COERCE-ERROR  --  Internal
  142. ;;;
  143. ;;;    Try to give a helpful error message when we fail to do a coercion
  144. ;;; for some reason.
  145. ;;;
  146. (defun bad-coerce-error (op)
  147.   (declare (type tn-ref op))
  148.   (let* ((op-tn (tn-ref-tn op))
  149.      (op-sc (tn-sc op-tn))
  150.      (op-scn (sc-number op-sc))
  151.      (ptype (tn-primitive-type op-tn))
  152.      (write-p (tn-ref-write-p op)))
  153.     (multiple-value-bind (arg-p pos more-p costs load-scs incon)
  154.              (get-operand-info op)
  155.       (declare (ignore costs more-p))
  156.       (collect ((load-lose)
  157.         (no-move-scs)
  158.         (move-lose))
  159.     (dotimes (i sc-number-limit)
  160.       (let ((i-sc (svref (backend-sc-numbers *backend*) i)))
  161.         (when (eq (svref load-scs i) t)
  162.           (cond ((not (sc-allowed-by-primitive-type i-sc ptype))
  163.              (load-lose i-sc))
  164.             ((not (find-move-vop op-tn write-p i-sc ptype
  165.                      #'sc-move-vops))
  166.              (let ((vops (if write-p
  167.                      (svref (sc-move-vops op-sc) i)
  168.                      (svref (sc-move-vops i-sc) op-scn))))
  169.                (if vops
  170.                (dolist (vop vops) (move-lose (template-name vop)))
  171.                (no-move-scs i-sc))))
  172.             (t
  173.              (error "Representation selection flamed out for no ~
  174.                      obvious reason."))))))
  175.     
  176.     (unless (or (load-lose) (no-move-scs) (move-lose))
  177.       (error "Representation selection flamed out for no obvious reason.~@
  178.               Try again after recompiling the VM definition."))
  179.  
  180.     (error "~S is not valid as the ~:R ~:[result~;argument~] to VOP:~
  181.             ~%  ~S~%Primitive type: ~S~@
  182.         SC restrictions:~%  ~S~@
  183.         ~@[The primitive type disallows these loadable SCs:~%  ~S~%~]~
  184.         ~@[No move VOPs are defined to coerce to these allowed SCs:~
  185.         ~%  ~S~%~]~
  186.         ~@[These move VOPs couldn't be used due to operand type ~
  187.         restrictions:~%  ~S~%~]~
  188.         ~:[~;~@
  189.         Current cost info inconsistent with that in effect at compile ~
  190.         time.  Recompile.~%Compilation order may be incorrect.~]"
  191.            op-tn pos arg-p
  192.            (template-name (vop-info (tn-ref-vop op)))
  193.            (primitive-type-name ptype)
  194.            (mapcar #'sc-name (listify-restrictions load-scs))
  195.            (mapcar #'sc-name (load-lose))
  196.            (mapcar #'sc-name (no-move-scs))
  197.            (move-lose)
  198.            incon)))))
  199.  
  200.  
  201. ;;; BAD-MOVE-ARG-ERROR  --  Internal
  202. ;;;
  203. (defun bad-move-arg-error (val pass)
  204.   (declare (type tn val pass))
  205.   (error "No :MOVE-ARGUMENT VOP defined to move ~S (SC ~S) to ~
  206.           ~S (SC ~S.)"
  207.      val (sc-name (tn-sc val))
  208.      pass (sc-name (tn-sc pass))))
  209.  
  210.  
  211. ;;;; VM Consistency Checking:
  212. ;;;
  213. ;;;    We do some checking of the consistency of the VM definition at load
  214. ;;; time.
  215.  
  216. ;;; CHECK-MOVE-FUNCTION-CONSISTENCY  --  Interface
  217. ;;;
  218. (defun check-move-function-consistency ()
  219.   (dotimes (i sc-number-limit)
  220.     (let ((sc (svref (backend-sc-numbers *backend*) i)))
  221.       (when sc
  222.     (let ((moves (sc-move-functions sc)))
  223.       (dolist (const (sc-constant-scs sc))
  224.         (unless (svref moves (sc-number const))
  225.           (warn "No move function defined to load SC ~S from constant ~
  226.                  SC ~S."
  227.             (sc-name sc) (sc-name const))))
  228.       
  229.       (dolist (alt (sc-alternate-scs sc))
  230.         (unless (svref moves (sc-number alt))
  231.           (warn "No move function defined to load SC ~S from alternate ~
  232.                  SC ~S."
  233.             (sc-name sc) (sc-name alt)))
  234.         (unless (svref (sc-move-functions alt) i)
  235.           (warn "No move function defined to save SC ~S to alternate ~
  236.                  SC ~S."
  237.             (sc-name sc) (sc-name alt)))))))))
  238.  
  239.  
  240. ;;;; Representation selection:
  241.  
  242. ;;; VOPs that we ignore in initial cost computation.  We ignore SET in the
  243. ;;; hopes that nobody is setting specials inside of loops.  We ignore
  244. ;;; TYPE-CHECK-ERROR because we don't want the possibility of error to bias the
  245. ;;; result.  Notes are suppressed for T-C-E as well, since we don't need to
  246. ;;; worry about the efficiency of that case.
  247. ;;;
  248. (defconstant ignore-cost-vops '(set type-check-error))
  249. (defconstant suppress-note-vops '(type-check-error))
  250.  
  251. (declaim (start-block select-tn-representation))
  252.  
  253. ;;; ADD-REPRESENTATION-COSTS  --  Local
  254. ;;;
  255. ;;;    We special-case the move VOP, since using this costs for the normal MOVE
  256. ;;; would spuriously encourage descriptor representations.  We won't actually
  257. ;;; need to coerce to descriptor and back, since we will replace the MOVE with
  258. ;;; a specialized move VOP.  What we do is look at the other operand.  If its
  259. ;;; representation has already been chosen (e.g.  if it is wired), then we use
  260. ;;; the appropriate move costs, otherwise we just ignore the references.
  261. ;;;
  262. (defun add-representation-costs (refs scs costs
  263.                       ops-slot costs-slot more-costs-slot
  264.                       write-p)
  265.   (do ((ref refs (tn-ref-next ref)))
  266.       ((null ref))
  267.     (flet ((add-costs (cost)
  268.          (dolist (scn scs)
  269.            (let ((res (svref cost scn)))
  270.          (unless res
  271.            (bad-costs-error ref))
  272.          (incf (svref costs scn) res)))))
  273.       (let* ((vop (tn-ref-vop ref))
  274.          (info (vop-info vop)))
  275.     (case (vop-info-name info)
  276.       (#.ignore-cost-vops)
  277.       (move
  278.        (let ((rep (tn-sc
  279.                (tn-ref-tn
  280.             (if write-p
  281.                 (vop-args vop)
  282.                 (vop-results vop))))))
  283.          (when rep
  284.            (if write-p
  285.            (dolist (scn scs)
  286.              (let ((res (svref (sc-move-costs
  287.                     (svref (backend-sc-numbers *backend*)
  288.                            scn))
  289.                        (sc-number rep))))
  290.                (when res
  291.              (incf (svref costs scn) res))))
  292.            (dolist (scn scs)
  293.              (let ((res (svref (sc-move-costs rep) scn)))
  294.                (when res
  295.              (incf (svref costs scn) res))))))))
  296.       (t
  297.        (do ((cost (funcall costs-slot info) (cdr cost))
  298.         (op (funcall ops-slot vop) (tn-ref-across op)))
  299.            ((null cost)
  300.         (add-costs (funcall more-costs-slot info)))
  301.          (when (eq op ref)
  302.            (add-costs (car cost))
  303.            (return))))))))
  304.   (undefined-value))
  305.  
  306.  
  307. ;;; SELECT-TN-REPRESENTATION  --  Internal
  308. ;;;
  309. ;;;    Return the best representation for a normal TN.  SCs is a list of the SC
  310. ;;; numbers of the SCs to select from.  Costs is a scratch vector.
  311. ;;;
  312. ;;;    What we do is sum the costs for each reference to TN in each of the
  313. ;;; SCs, and then return the SC having the lowest cost.
  314. ;;;
  315. (defun select-tn-representation (tn scs costs)
  316.   (declare (type tn tn) (type sc-vector costs)
  317.        (inline add-representation-costs))
  318.   (dolist (scn scs)
  319.     (setf (svref costs scn) 0))
  320.   
  321.   
  322.   (add-representation-costs (tn-reads tn) scs costs
  323.                 #'vop-args #'vop-info-arg-costs
  324.                 #'vop-info-more-arg-costs
  325.                 nil)
  326.   (add-representation-costs (tn-writes tn) scs costs
  327.                 #'vop-results #'vop-info-result-costs
  328.                 #'vop-info-more-result-costs
  329.                 t)
  330.   
  331.   (let ((min most-positive-fixnum)
  332.     (min-scn nil))
  333.     (dolist (scn scs)
  334.       (let ((cost (svref costs scn)))
  335.     (when (< cost min)
  336.       (setq min cost)
  337.       (setq min-scn scn))))
  338.     
  339.     (svref (backend-sc-numbers *backend*) min-scn)))
  340.  
  341. (declaim (end-block))
  342.  
  343.  
  344. ;;; NOTE-NUMBER-STACK-TN  --  Internal
  345. ;;;
  346. ;;;    Prepare for the possibility of a TN being allocated on the number stack
  347. ;;; by setting NUMBER-STACK-P in all functions that TN is referenced in and in
  348. ;;; all the functions in their tail sets.  Refs is a TN-Refs list of references
  349. ;;; to the TN.
  350. ;;;
  351. (defun note-number-stack-tn (refs)
  352.   (declare (type (or tn-ref null) refs))
  353.   
  354.   (do ((ref refs (tn-ref-next ref)))
  355.       ((null ref))
  356.     (let* ((lambda (block-home-lambda
  357.             (ir2-block-block
  358.              (vop-block (tn-ref-vop ref)))))
  359.        (tails (lambda-tail-set lambda)))
  360.       (flet ((frob (fun)
  361.            (setf (ir2-environment-number-stack-p
  362.               (environment-info
  363.                (lambda-environment fun)))
  364.              t)))
  365.     (frob lambda)
  366.     (when tails
  367.       (dolist (fun (tail-set-functions tails))
  368.         (frob fun))))))
  369.  
  370.   (undefined-value))
  371.  
  372.  
  373. ;;; GET-OPERAND-NAME  --  Internal
  374. ;;;
  375. ;;;    If TN is a variable, return the name.  If TN is used by a VOP emitted
  376. ;;; for a return, then return a string indicating this.  Otherwise, return NIL.
  377. ;;;
  378. (defun get-operand-name (tn arg-p)
  379.   (declare (type tn tn))
  380.   (let* ((actual (if (eq (tn-kind tn) :alias) (tn-save-tn tn) tn))
  381.      (reads (tn-reads tn))
  382.      (leaf (tn-leaf actual)))
  383.     (cond ((lambda-var-p leaf) (leaf-name leaf))
  384.       ((and (not arg-p) reads
  385.         (return-p (vop-node (tn-ref-vop reads))))
  386.        "<return value>")
  387.       (t
  388.        nil))))
  389.  
  390.  
  391. ;;; DO-COERCE-EFFICIENCY-NOTE  --  Internal
  392. ;;;
  393. ;;;    If policy indicates, give an efficiency note for doing the a coercion
  394. ;;; Vop, where Op is the operand we are coercing for and Dest-TN is the
  395. ;;; distinct destination in a move.
  396. ;;;
  397. (defun do-coerce-efficiency-note (vop op dest-tn)
  398.   (declare (type vop-info vop) (type tn-ref op) (type (or tn null) dest-tn))
  399.   (let* ((note (or (template-note vop) (template-name vop)))
  400.      (cost (template-cost vop))
  401.      (op-vop (tn-ref-vop op))
  402.      (op-node (vop-node op-vop))
  403.      (op-tn (tn-ref-tn op))
  404.      (*compiler-error-context* op-node))
  405.     (cond ((eq (tn-kind op-tn) :constant))
  406.       ((policy op-node (<= speed brevity) (<= space brevity)))
  407.       ((member (template-name (vop-info op-vop)) suppress-note-vops))
  408.       ((null dest-tn)
  409.        (let* ((op-info (vop-info op-vop))
  410.           (op-note (or (template-note op-info)
  411.                    (template-name op-info)))
  412.           (arg-p (not (tn-ref-write-p op)))
  413.           (name (get-operand-name op-tn arg-p))
  414.           (pos (1+ (or (position-in #'tn-ref-across op
  415.                         (if arg-p
  416.                         (vop-args op-vop)
  417.                         (vop-results op-vop)))
  418.                    (error "Couldn't fine op?  Bug!")))))
  419.          (compiler-note
  420.           "Doing ~A (cost ~D)~:[~2*~; ~:[to~;from~] ~S~], for:~%~6T~
  421.            The ~:R ~:[result~;argument~] of ~A."
  422.           note cost name arg-p name
  423.           pos arg-p op-note)))
  424.       (t
  425.        (compiler-note "Doing ~A (cost ~D)~@[ from ~S~]~@[ to ~S~]."
  426.               note cost (get-operand-name op-tn t)
  427.               (get-operand-name dest-tn nil)))))
  428.   (undefined-value))
  429.  
  430.  
  431. ;;; FIND-MOVE-VOP  --  Internal
  432. ;;;
  433. ;;;    Find a move VOP to move from the operand OP-TN to some other
  434. ;;; representation corresponding to OTHER-SC and OTHER-PTYPE.  Slot is the SC
  435. ;;; slot that we grab from (move or move-argument).  Write-P indicates that OP
  436. ;;; is a VOP result, so OP is the move result and other is the arg, otherwise
  437. ;;; OP is the arg and other is the result.
  438. ;;;
  439. ;;;    If an operand is of primitive type T, then we use the type of the other
  440. ;;; operand instead, effectively intersecting the argument and result type
  441. ;;; assertions.  This way, a move VOP can restrict whichever operand makes more
  442. ;;; sense, without worrying about which operand has the type info.
  443. ;;;
  444. (defun find-move-vop (op-tn write-p other-sc other-ptype slot)
  445.   (declare (type tn op-tn) (type sc other-sc)
  446.        (type primitive-type other-ptype)
  447.        (type function slot))
  448.   (let* ((op-sc (tn-sc op-tn))
  449.      (op-scn (sc-number op-sc))
  450.      (other-scn (sc-number other-sc))
  451.      (any-ptype (backend-any-primitive-type *backend*))
  452.      (op-ptype (tn-primitive-type op-tn)))
  453.     (let ((other-ptype (if (eq other-ptype any-ptype) op-ptype other-ptype))
  454.       (op-ptype (if (eq op-ptype any-ptype) other-ptype op-ptype)))
  455.       (dolist (info (if write-p
  456.             (svref (funcall slot op-sc) other-scn)
  457.             (svref (funcall slot other-sc) op-scn))
  458.             nil)
  459.     (when (and (operand-restriction-ok
  460.             (first (template-arg-types info))
  461.             (if write-p other-ptype op-ptype)
  462.             :tn op-tn :t-ok nil)
  463.            (operand-restriction-ok
  464.             (first (template-result-types info))
  465.             (if write-p op-ptype other-ptype)
  466.             :t-ok nil))
  467.       (return info))))))
  468.  
  469.     
  470. ;;; EMIT-COERCE-VOP  --  Internal
  471. ;;;
  472. ;;;    Emit a coercion VOP for Op Before the specifed VOP or die trying.  SCS
  473. ;;; is the operand's LOAD-SCS vector, which we use to determine what SCs the
  474. ;;; VOP will accept.  We pick any acceptable coerce VOP, since it practice it
  475. ;;; seems uninteresting to have more than one applicable.
  476. ;;;
  477. ;;;    What we do is look at each SC allowed by both the operand restriction
  478. ;;; and the operand primitive-type, and see if there is a move VOP which moves
  479. ;;; between the operand's SC and load SC.  If we find such a VOP, then we make
  480. ;;; a TN having the load SC as the representation.
  481. ;;;
  482. ;;;    Dest-TN is the TN that we are moving to, for a move or move-arg.  This
  483. ;;; is only for efficiency notes.
  484. ;;;
  485. ;;;    If the TN is an unused result TN, then we don't actually emit the move;
  486. ;;; we just change to the right kind of TN.
  487. ;;;
  488. (defun emit-coerce-vop (op dest-tn scs before)
  489.   (declare (type tn-ref op) (type sc-vector scs) (type (or vop null) before)
  490.        (type (or tn null) dest-tn))
  491.   (let* ((op-tn (tn-ref-tn op))
  492.      (ptype (tn-primitive-type op-tn))
  493.      (write-p (tn-ref-write-p op))
  494.      (vop (tn-ref-vop op))
  495.      (node (vop-node vop))
  496.      (block (vop-block vop)))
  497.     (dotimes (i sc-number-limit (bad-coerce-error op))
  498.       (let ((i-sc (svref (backend-sc-numbers *backend*) i)))
  499.     (when (and (eq (svref scs i) t)
  500.            (sc-allowed-by-primitive-type i-sc ptype))
  501.       (let ((res (find-move-vop op-tn write-p i-sc ptype #'sc-move-vops)))
  502.         (when res
  503.           (when (>= (vop-info-cost res) *efficiency-note-cost-threshold*)
  504.         (do-coerce-efficiency-note res op dest-tn))
  505.           (let ((temp (make-representation-tn ptype i)))
  506.         (change-tn-ref-tn op temp)
  507.         (cond
  508.          ((not write-p)
  509.           (emit-move-template node block res op-tn temp before))
  510.          ((and (null (tn-reads op-tn))
  511.                (eq (tn-kind op-tn) :normal)))
  512.          (t
  513.           (emit-move-template node block res temp op-tn before))))
  514.           (return))))))))
  515.  
  516.  
  517. ;;; COERCE-SOME-OPERANDS  --  Internal
  518. ;;;
  519. ;;;    Scan some operands and call EMIT-COERCE-VOP on any for which we can't
  520. ;;; load the operand.  The coerce VOP is inserted Before the specified VOP.
  521. ;;; Dest-TN is the destination TN if we are doing a move or move-arg, and is
  522. ;;; NIL otherwise.  This is only used for efficiency notes.
  523. ;;;
  524. (proclaim '(inline coerce-some-operands))
  525. (defun coerce-some-operands (ops dest-tn load-scs before)
  526.   (declare (type (or tn-ref null) ops) (list load-scs)
  527.        (type (or tn null) dest-tn) (type (or vop null) before))
  528.   (do ((op ops (tn-ref-across op))
  529.        (scs load-scs (cdr scs)))
  530.       ((null scs))
  531.     (unless (svref (car scs)
  532.            (sc-number (tn-sc (tn-ref-tn op))))
  533.       (emit-coerce-vop op dest-tn (car scs) before)))
  534.   (undefined-value))
  535.  
  536.  
  537. ;;; COERCE-VOP-OPERANDS  --  Internal
  538. ;;;
  539. ;;;    Emit coerce VOPs for the args and results, as needed.
  540. ;;;
  541. (defun coerce-vop-operands (vop)
  542.   (declare (type vop vop))
  543.   (let ((info (vop-info vop)))
  544.     (coerce-some-operands (vop-args vop) nil (vop-info-arg-load-scs info) vop)
  545.     (coerce-some-operands (vop-results vop) nil (vop-info-result-load-scs info)
  546.               (vop-next vop)))
  547.   (undefined-value))
  548.  
  549.  
  550. ;;; EMIT-ARG-MOVES  --  Internal
  551. ;;;
  552. ;;;    Iterate over the more operands to a call VOP, emitting move-arg VOPs and
  553. ;;; any necessary coercions.  We determine which FP to use by looking at the
  554. ;;; MOVE-ARGS annotation.  If the vop is a :LOCAL-CALL, we insert any needed
  555. ;;; coercions before the ALLOCATE-FRAME so that lifetime analysis doesn't get
  556. ;;; confused (since otherwise, only passing locations are written between A-F
  557. ;;; and call.)
  558. ;;;
  559. (defun emit-arg-moves (vop)
  560.   (let* ((info (vop-info vop))
  561.      (node (vop-node vop))
  562.      (block (vop-block vop))
  563.      (how (vop-info-move-args info))
  564.      (args (vop-args vop))
  565.      (fp-tn (tn-ref-tn args))
  566.      (nfp-tn (if (eq how :local-call)
  567.              (tn-ref-tn (tn-ref-across args))
  568.              nil))
  569.      (pass-locs (first (vop-codegen-info vop)))
  570.      (prev (vop-prev vop)))
  571.     (do ((val (do ((arg args (tn-ref-across arg))
  572.            (req (template-arg-types info) (cdr req)))
  573.           ((null req) arg))
  574.           (tn-ref-across val))
  575.      (pass pass-locs (cdr pass)))
  576.     ((null val)
  577.      (assert (null pass)))
  578.       (let* ((val-tn (tn-ref-tn val))
  579.          (pass-tn (first pass))
  580.          (pass-sc (tn-sc pass-tn))
  581.          (res (find-move-vop val-tn nil pass-sc
  582.                  (tn-primitive-type pass-tn)
  583.                  #'sc-move-arg-vops)))
  584.     (unless res
  585.       (bad-move-arg-error val-tn pass-tn))
  586.     
  587.     (change-tn-ref-tn val pass-tn)
  588.     (let* ((this-fp
  589.         (cond ((not (sc-number-stack-p pass-sc)) fp-tn)
  590.               (nfp-tn)
  591.               (t
  592.                (assert (eq how :known-return))
  593.                (setq nfp-tn (make-number-stack-pointer-tn))
  594.                (setf (tn-sc nfp-tn)
  595.                  (svref (backend-sc-numbers *backend*)
  596.                     (first (primitive-type-scs
  597.                         (tn-primitive-type nfp-tn)))))
  598.                (emit-context-template
  599.             node block
  600.             (template-or-lose 'compute-old-nfp *backend*)
  601.             nfp-tn vop)
  602.                (assert (not (sc-number-stack-p (tn-sc nfp-tn))))
  603.                nfp-tn)))
  604.            (new (emit-move-arg-template node block res val-tn this-fp
  605.                         pass-tn vop))
  606.            (after
  607.         (cond ((eq how :local-call)
  608.                (assert (eq (vop-info-name (vop-info prev))
  609.                    'allocate-frame))
  610.                prev)
  611.               (prev (vop-next prev))
  612.               (t
  613.                (ir2-block-start-vop block)))))
  614.       (coerce-some-operands (vop-args new) pass-tn
  615.                 (vop-info-arg-load-scs res)
  616.                 after)))))
  617.   (undefined-value))
  618.  
  619.  
  620. ;;; EMIT-MOVES-AND-COERCIONS  --  Internal
  621. ;;;
  622. ;;;    Scan the IR2 looking for move operations that need to be replaced with
  623. ;;; special-case VOPs and emitting coercion VOPs for operands of normal VOPs.
  624. ;;; We delete moves to TNs that are never read at this point, rather than
  625. ;;; possibly converting them to some expensive move operation.
  626. ;;;
  627. (defun emit-moves-and-coercions (block)
  628.   (declare (type ir2-block block))
  629.   (do ((vop (ir2-block-start-vop block)
  630.         (vop-next vop)))
  631.       ((null vop))
  632.     (let ((info (vop-info vop))
  633.       (node (vop-node vop))
  634.       (block (vop-block vop)))
  635.       (cond
  636.        ((eq (vop-info-name info) 'move)
  637.     (let* ((args (vop-args vop))
  638.            (x (tn-ref-tn args))
  639.            (y (tn-ref-tn (vop-results vop)))
  640.            (res (find-move-vop x nil (tn-sc y) (tn-primitive-type y)
  641.                    #'sc-move-vops)))
  642.       (cond ((and (null (tn-reads y))
  643.               (eq (tn-kind y) :normal))
  644.          (delete-vop vop))
  645.         ((eq res info))
  646.         (res
  647.          (when (>= (vop-info-cost res)
  648.                *efficiency-note-cost-threshold*)
  649.            (do-coerce-efficiency-note res args y))
  650.          (emit-move-template node block res x y vop)
  651.          (delete-vop vop))
  652.         (t
  653.          (coerce-vop-operands vop)))))
  654.        ((vop-info-move-args info)
  655.     (emit-arg-moves vop))
  656.        (t
  657.     (coerce-vop-operands vop))))))
  658.  
  659.  
  660. ;;; NOTE-IF-NUMBER-STACK  --  Internal
  661. ;;;
  662. ;;;    If TN is in a number stack SC, make all the right annotations.  Note
  663. ;;; that this should be called after TN has been referenced, since it must
  664. ;;; iterate over the referencing environments.
  665. ;;;
  666. (proclaim '(inline note-if-number-stack))
  667. (defun note-if-number-stack (tn 2comp restricted)
  668.   (declare (type tn tn) (type ir2-component 2comp))
  669.   (when (if restricted
  670.         (eq (sb-name (sc-sb (tn-sc tn))) 'non-descriptor-stack)
  671.         (sc-number-stack-p (tn-sc tn)))
  672.     (unless (ir2-component-nfp 2comp)
  673.       (setf (ir2-component-nfp 2comp) (make-nfp-tn)))
  674.     (note-number-stack-tn (tn-reads tn))
  675.     (note-number-stack-tn (tn-writes tn)))
  676.   (undefined-value))
  677.  
  678.  
  679. ;;; SELECT-REPRESENTATIONS  --  Interface
  680. ;;;
  681. ;;;    Entry to representation selection.  First we select the representation
  682. ;;; for all normal TNs, setting the TN-SC.  After selecting the TN
  683. ;;; representations, we set the SC for all :ALIAS TNs to be the representation
  684. ;;; chosen for the original TN.  We then scan all the IR2, emitting any
  685. ;;; necessary coerce and move-arg VOPs.  Finally, we scan all TNs looking for
  686. ;;; ones that might be placed on the number stack, noting this so that the
  687. ;;; number-FP can be allocated.  This must be done last, since references in
  688. ;;; new environments may be introduced by MOVE-ARG insertion.
  689. ;;;
  690. (defun select-representations (component)
  691.   (let ((costs (make-array sc-number-limit))
  692.     (2comp (component-info component)))
  693.             
  694.     (do ((tn (ir2-component-normal-tns 2comp)
  695.          (tn-next tn)))
  696.     ((null tn))
  697.       (assert (tn-primitive-type tn))
  698.       (unless (tn-sc tn)
  699.     (let* ((scs (primitive-type-scs (tn-primitive-type tn)))
  700.            (sc (if (rest scs)
  701.                (select-tn-representation tn scs costs)
  702.                (svref (backend-sc-numbers *backend*) (first scs)))))
  703.       (assert sc)
  704.       (setf (tn-sc tn) sc))))
  705.  
  706.     (do ((alias (ir2-component-alias-tns 2comp)
  707.         (tn-next alias)))
  708.     ((null alias))
  709.       (setf (tn-sc alias) (tn-sc (tn-save-tn alias))))
  710.  
  711.     (do-ir2-blocks (block component)
  712.       (emit-moves-and-coercions block))
  713.     
  714.     (macrolet ((frob (slot restricted)
  715.          `(do ((tn (,slot 2comp) (tn-next tn)))
  716.               ((null tn))
  717.             (note-if-number-stack tn 2comp ,restricted))))
  718.       (frob ir2-component-normal-tns nil)
  719.       (frob ir2-component-wired-tns t)
  720.       (frob ir2-component-restricted-tns t)))
  721.  
  722.   (undefined-value))
  723.